COMMENT ⊗   VALID 00022 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	 Simulator for Multi-processing Lisp.
C00009 00003	 Things to do
C00011 00004	 Defstructs
C00022 00005	 Metering
C00027 00006	 Process Loop
C00037 00007	 Environment Stuff
C00040 00008	 Simple Interpreter M-EVAL
C00051 00009	 M-SUBR's for Everything
C00061 00010	 Simple Interpreter M-APPLY
C00073 00011	 COND, OR, AND, NOT
C00076 00012	 PROGN
C00078 00013	 SETQ
C00080 00014	 QLAMBDA
C00099 00015	 CATCH/THROW
C00104 00016	 DO
C00108 00017	 Definitions
C00109 00018	 Simple Allocation Routines
C00111 00019	 Simple 1-dimensional array stuff
C00112 00020	 Useful Macros for the Running System.
C00113 00021	 Simple Lock Mechanism
C00117 00022	 Startup
C00122 ENDMK
C⊗;
;;; Simulator for Multi-processing Lisp.

(declare
 (mapex t)
 (fixsw t)
 (setq defmacro-for-compiling ())
 (setq backquote-expand-when 'read)
 (or (get 'defstruct 'version)
     (fasload struct fas lisp)))

(declare (special *meter* *function* *process-creation-time* *read-time*
	  *val* *write-time* *points* *graphp* *xfun* *yfun* *silence* *time*
	  *pc-stack* *arg-stack* *environment* *machine* *self* *valuep* *recent-vars*
	  *tag* *catch-thread* *pc-stack* *arg-stack* *evarg-stack* *variable-conflict-window*
	  *keep-load-history* *allocate-stack*))

(declare (special *number-of-processes*)
         (fixnum *number-of-processes*))

(declare (special *max-number-of-processes*)
         (fixnum *max-number-of-processes*))

(setq *number-of-processes* 0)

;;; *VALUEP* can be one of:
;;;	tail-recursive = this is a tail recursive call forming the value of the function
;;;	in-progn-tail  = this is a tail recursive call in a progn
;;;	argument       = this is a call whose value is a argument to something else
;;;	()	       = the value of this call can be thrown away

(defmacro tail-recursivep (x) `(memq ,x '(tail-recursive in-progn-tail)))

(setq *number-of-processes* 0)
(setq *process-creation-time* 0)
(setq *time* 0)
(setq *variable-conflict-window* 0)
(setq *keep-load-history* ())
(setq *read-time* 0)
(setq *write-time* 0)
(setq *graphp* () *silence* ())
(setq *xfun* () *yfun* ())

(defmacro m-init-world ()
	  `(setq *pc-stack* () *arg-stack* () *evarg-stack* () *environment* ()
		 *number-of-processes* 0 *allocate-stack* ()
		 *recent-vars* () *valuep* ()))

(eval-when (eval) (defmacro m-subr-funcall (x y)
			    `(funcall ,x ,y)))

(eval-when (compile) (defmacro m-subr-funcall (x y)
			       `(subrcall t ,x ,y)))

(eval-when (load) (*rset (nouuo ()))
	   (setq base 10. ibase 10.))

(defstruct queue
	   (qhead ())
	   (qtail ()))

(defun queue-head (q) (car (qhead q)))

(defun queue-tail (q) (car (qtail q)))

(defun next-queue (q) (cadr (qhead q)))

(defun add-queue (item q)
       (cond ((null (qhead q))
	      (let ((x (ncons item)))
		   (setf (cdr x) x)
		   (setf (qhead q) x)
		   (setf (qtail q) x)
		   item))
	     (t
	      (let ((x (ncons item)))
		   (setf (cdr x) (qhead q))
		   (setf (cdr (qtail q))
			 x)
		   (setf (qtail q) x)
		   item))))

(defun get-queue (q)
       (prog1
	(car (qhead q))
	(setf (qtail q) (qhead q))
	(setf (qhead q) (cdr (qhead q)))))

(defun remove-queue (item q)
       (let ((qh (qhead q))
	     (qt (qtail q)))
	    (cond ((eq qh qt)
		   (cond ((eq item (car qh))
			  (setf (qhead q) ())
			  (setf (qtail q) ())
			  item)))
		  ((eq (car qh) item)
		   (setf (qhead q)(cdr qh))
		   (setf (cdr qt) (cdr qh))
		   item)
		  (t 
		   (do ((x qh (cdr x))
			(y (cdr qh) (cdr y)))
		       ((eq y qt)
			(cond ((eq item (car y))
				 (setf (qtail q)
				       x)
				 (setf (cdr x)
				       (qhead q))
				 item)))
			 (cond ((eq item (car y))
				(setf (cdr x)
				      (cdr y))
				(return item))))))))

(defun remove-head-queue (q)
       (let ((qh (qhead q))
	     (qt (qtail q)))
	    (cond ((eq qh qt)
		   (setf (qhead q) ())
		   (setf (qtail q) ())
		   (car qh))
		  (t
		   (setf (qhead q)(cdr qh))
		   (setf (cdr qt) (cdr qh))
		   (car qh)))))

(defmacro tab ()
	  `(tyo #o9))

(defun m-flush-top-arg-stack ()
       (pop *arg-stack*))

(defmacro copy (l)
	  `(mapcar #'(lambda (x) x) ,l))

(defmacro copy-environment (l)
	  `(mapcar #'(lambda (x) (cons (car x) (cdr x))) ,l))
;;; Things to do

;;; 1. NO-RETURN-VALUE in 3600 version

;;; 2. Communications overhead modelling

;;; 3. Scheduling overhead modelling

;;; 4. *process-creation-time* etc REPORTing in 3600

;;; 5. Load average in 3600

;;; 6. M-EVAL as a user-callable in 3600 (entry in M-eval for M-eval)

;;; 7. SUSPEND-PROCESS checking for (eq job *self*) in 3600.
;;;    RESUME-PROCESS too.

;;; 8. In M-QLAMBDA-APPLY, if PRED is MULTL, (REVERSE DESTINATIONS)
;;;    in the (eq multip 'lazy) arm in 3600.

;;; 9. ((F 2) 3) now works. Last clause in M-EVAL and M-EVAL-2

;;; 10.LAZY => EAGER in 3600.

;;; 11. M-QLAMBDA-APPLY => M-QLET-QCLOSURE-APPLY

;;; 12. ((QLAMBDA ...)...) => QLET

;;; 13. Lock stuff

;;; 14. Added IN-PROGN to EVPROGN and to M-EVAL. If you see:
;;;	(progn ... <funcall> ...), then the environment is saved and restored.
;;; Defstructs

(defstruct (machine
	    (conc-name machine-))
	   (number 0)
	   (list ())			;jobs to run
	   (processors ()))

(defstruct (processor
	    (conc-name processor-))
	   (queue-length 0)
	   (job-queue (make-queue)))
	   
(defstruct (value-dest
	    (conc-name value-dest-))
	   (type 'processor)
	   (destination ())) 

;;; Job-active can have these meanings:
;;;	alive 	= running
;;;	ready	= ready to run
;;;	dead	= flushable
;;;	wait	= waiting for an event
;;;	locked	= unkillable
;;;	suicidal= kill on unlock

(defstruct job
	   (arg-stack ())
	   (pc-stack ())
	   (evarg-stack ())
	   (environment ())
	   (valuep 'tail-recursive)
	   (closure-expression ())
	   (catch-thread ())
	   (job-waiter 'm-null-wait)	;function that decides when waiting is over
	   (job-values ())		;values come here
	   (job-list ()) 		;a list of jobs to substitute for
					;this one when this one dies!
	   (job-expression ())		;expression this job is computing
	   (job-dest-id ())		;identification for the return message
	   (job-value-dest ())		;destination of the value
	   				; see above
	   (job-active 'dead)))		;values are dead, alive, wait

(defmacro copy-job (job)
	  `(let ((job ,job))
		(make-job
		 arg-stack (arg-stack job)
		 pc-stack (pc-stack job)
		 evarg-stack (evarg-stack job)
		 environment (environment job)
		 valuep (valuep job)
		 catch-thread (catch-thread job)
		 closure-expression (closure-expression job)
		 job-waiter (job-waiter job)
		 job-values (job-values job)
		 job-list (job-list job)
		 job-expression (job-expression job)
		 job-dest-id (job-dest-id job)
		 job-value-dest (job-value-dest job)
		 job-active (job-active job))))

(defmacro restore-state (job)
	  `(let ((job ,job))
		(setq *pc-stack* (pc-stack job)
		      *arg-stack* (arg-stack job)
		      *evarg-stack* (evarg-stack job)
		      *self* job
		      *valuep* (valuep job)
		      *environment* (environment job)
		      *catch-thread* (catch-thread job))))

(defmacro save-state (job)
	  `(let ((job ,job))
		(setf (pc-stack job) *pc-stack*)
		(setf (arg-stack job) *arg-stack*)
		(setf (evarg-stack job) *evarg-stack*)
		(setf (valuep job) *valuep*)
		(setf (environment job) *environment*)
		(setf (catch-thread job) *catch-thread*)))

(defmacro top (stack)
	  `(car ,stack))

(defmacro rfirst-n (n l)
	  `(do ((n ,n (1- n))
		(a () ))
	       ((zerop n) a)
	       (push (pop ,l) a)))

(defstruct (return-message
	    (conc-name return-message-))
	   (id ())
	   (contents ()))

(defmacro push-all (l s)
	  `(setf ,s (append ,l ,s)))

(defmacro find-message (id messages)
	  `(do ((mess ,messages (cdr mess))
		(id ,id))
	       ((null mess) ())
	       (cond ((eq (return-message-id (car mess)) id)
		      (return (car mess))))))

(defstruct (job-closure 
	    (conc-name job-closure-))
	   (processor ())
	   (argument-type 'normal)	;can be eager
	   (eager-cells ())		;and, if so, here they are
	   (job ()))

(defmacro make-qclosure (args job-record)
	  `(list 'qclosure ,args ,job-record))

(defmacro qclosurep (x)
	  `(let ((x ,x))
		(and (not (atom x))
		     (eq (car x) 'qclosure))))

(defmacro qclosure-args (x)
	  `(cadr ,x))

(defmacro qclosure-job-record (x)
	  `(caddr ,x))

(defun m-restore-valuep ()
       (setq *valuep* (pop *pc-stack*)))

(defstruct (unwind-protect-waiter
	    (conc-name unwind-protect-waiter-))
	   (valid ()))

(defstruct (unwind-protect-cleanup
	    (conc-name unwind-protect-cleanup-))
	   (environment ())
	   (job ())
	   (form ())) 

(defstruct
 (catch-record
  (conc-name catch-record-))
 (tag ())
 (jobs ())
 (job ())
 (cleanups ())
 (evarg-stack ())
 (arg-stack ())
 (pc-stack ())
 (valuep ())
 (catch-thread ())
 (job-list ())
 (job-values ())
 (environment ()))

(defmacro m-push (a l)
	  `(setf ,l (cons ,a ,l)))

(defmacro m-pop (l)
	  `(prog1
	    (car ,l)
	    (setf ,l (cdr ,l))))

;;; This kills process closures, flushes them from the catch-thread, and
;;; deletes the unwind-protect cleanups

(defun kill-all-closure-jobs (l)
 (do ((l l (cdr l)))
     ((null l) 
      t)
     (do ((th *catch-thread* (catch-record-catch-thread th)))
	 ((null th) t)
	 (setf (catch-record-jobs th)
	       (delq (job-closure-job (car l))
		     (catch-record-jobs th))))
     (let ((processor (job-closure-processor (car l))))
	  (cond (processor
		 (let ((job (job-closure-job (car l))))
		 (caseq (job-active job)
			((alive wait dead)
			 (remove-queue job
				       (processor-job-queue
					processor)))
			(locked (setf (job-active job) 'suicidal))
			(suicidal)
			(t ()))))))))

(defmacro catch-restore-state (job record)
	  `(let ((job ,job)
		 (record ,record))
		(setf (pc-stack job) (catch-record-pc-stack record))
		(setf (arg-stack job) (catch-record-arg-stack record))
		(setf (evarg-stack job) (catch-record-evarg-stack record))
		(setf (valuep job) (catch-record-valuep record))
		(setf (environment job) (catch-record-environment record))
		(setf (job-list job)(catch-record-job-list record))
		(setf (job-values job)(catch-record-job-values record))
		))

(defmacro catch-restore-self (record)
	  `(let ((record ,record))
		(setq *pc-stack* (catch-record-pc-stack record))
		(setq *arg-stack* (catch-record-arg-stack record))
		(setq *evarg-stack* (catch-record-evarg-stack record))
		(setq *valuep* (catch-record-valuep record))
		(setq *environment* (catch-record-environment record))
		(setf (job-list *self*) (catch-record-job-list record))
		(setf (job-values *self*) (catch-record-job-values record))
		))

(defmacro m-add-job-list (job item)
	  `(do ((job ,job (job-list job)))
	       ((null (job-list job)) 
		(setf (job-list job) ,item))) )

(defmacro make-eager-cell ()
	  `(list 'eager 'empty ()))

(defmacro eager-cellp (x)
	  `(eq (car ,x) 'eager))

(defmacro eager-cell-fullp (x)
	  `(eq (cadr ,x) 'full))

(defmacro eager-cell-full (x)
	  `(cadr ,x))

(defmacro eager-cell-value (x)
	  `(caddr ,x))

;;; Deletes everything from l that is in d, destructively

(defun delete-em-all (d l)
       (do ((x l (cdr x)))
	   ((not (memq (car x) d)) (setq l x)))
       (do ((p1 l (cdr p1))
	    (p2 (cdr l) (cdr p2)))
	   ((null p2) l)
	   (cond ((memq (car p2) d)
		  (setf (cdr p1) (cdr p2))
		  (setq p2 (cdr p2))))))

(defun current-load ()
       (do ((p (machine-processors *machine*) (cdr p))
	    (n 0))
	   ((null p) n)
	   (setq n (+ (processor-queue-length (car p)) n))))

(defmacro make-internal-qlet (vars exprs body)
	  `(list 'internal-qlet ,vars ,exprs ,body))

(defmacro internal-qlet-vars (x)
	  `(cadr ,x))

(defmacro internal-qlet-exprs (x)
	  `(caddr ,x))

(defmacro internal-qlet-body (x)
	  `(cadddr ,x))
;;; Metering

(defstruct (meter
	    (conc-name meter-))
	   (processes 0)
	   (scheduled-processes 0)
	   (load-history ())
	   (processors 0)
	   (wait-cycles 0)
	   (active-cycles 0)
	   (read-conflicts 0)
	   (write-conflicts 0)
	   (multicycles 0))

(defmacro incf (slot)
	  `(setf ,slot (1+ ,slot)))

(defmacro decf (slot)
	  `(setf ,slot (1- ,slot)))

(defun report ()
       (cond (*graphp*
	      (setq *points*
		    (nconc *points* 
			   `((,(cond (*xfun*
				      (funcall *xfun*))
				     (t (meter-processors *meter*)))
			      ,(cond (*yfun*
				      (funcall *yfun*))
				     (t (meter-multicycles *meter*)))))))))
       (cond (*silence*)
	     (t (terpri)
		(princ "Number of Processors:")
		(tab)
		(princ (meter-processors *meter*))
		(terpri)
		(princ "Process Creation Time")
		(tab)
		(princ *process-creation-time*)
		(terpri)
		(princ "Global Read Time")
		(tab)
		(princ *read-time*)
		(terpri)
		(princ "Global Write Time")
		(tab)
		(princ *write-time*)
		(terpri)
		(princ "Processes Created:")
		(tab)
		(princ (meter-processes *meter*))
		(terpri)
		(princ "Processes Scheduled:")
		(tab)
		(princ (meter-scheduled-processes *meter*))
		(terpri)
		(princ "Read Conflicts:")
		(tab)(tab)
		(princ (meter-read-conflicts *meter*))
		(terpri)
		(princ "Write Conflicts:")
		(tab)
		(princ (meter-write-conflicts *meter*))
		(terpri)
		(princ "Wait Cycles:")
		(tab)(tab)
		(princ (meter-wait-cycles *meter*))
		(terpri)
		(princ "Active Cycles:")
		(tab)(tab)
		(princ (meter-active-cycles *meter*))
		(terpri)
		(princ "Multiprocessor Steps:")
		(tab)
		(princ (meter-multicycles *meter*))
		(terpri)
		(cond (*keep-load-history*
		       (report-load-history))))))

(defun recent-var-memq (var l)
       (do ((q *recent-vars* (cdr q)))
	   ((null q) ())
	   (cond ((and (eq (car (car l))
			   var)
		       (not (eq (cdr (car l))
				*self*)))
		  (return l)))))

(defun report-load-history ()
       (let ((hh (meter-load-history *meter*)))
	    (do ((h hh (cdr h))
		 (len 0)
		 (sum 0)
		 (max (car hh)))
		((null h) 
		 (let ((average
		          (//$ (float sum)(float len))))
		      (princ "Max Load")(tab)(tab)(princ max)(terpri)
		      (princ "Average Load")(tab)(tab)
		      (princ (round-fun average))
		      (terpri)
		      (princ "Standard Deviation")(tab)
		      (princ (round-fun (standard-deviation hh len average)))
		      (terpri)))
		(setq len (1+ len))
		(setq sum (+ (car h) sum))
		(setq max (max max (car h))))))

(defun round-fun (x)
       (//$ (float (fix (+$ .5 (*$ x 100.0)))) 100.0))

		
(defun standard-deviation (l len average)
       (do ((l l (cdr l))
	    (sum 0.0))
	   ((null l)
	    (//$ (sqrt sum) (float len)))
	   (setq sum (+$ sum (let ((d (-$ average (float (car l)))))
				  (*$ d d))))))
;;; Process Loop

;;; Steps once for each processor

(defun multi-process (machine)
       (cond ((machine-list machine)
	      (multi-schedule (machine-list machine)
			      (machine-processors machine))
	      (setf (machine-list machine) ())))
       (do ((all-wait t)
	    (all-dead t)
	    (i 2 (1- i)))
	   ((or (null all-wait) 
		(zerop i))
	    all-dead)
	   (do ((pr (machine-processors machine) (cdr pr))
;               (n 1 (1+ n))
		(processor ()))
	       ((null pr))
;	       (print `(processor ,n))
	       (setq processor (car pr))
	       (let* ((queue (processor-job-queue processor))
		      (last (queue-tail queue))
		      (job (get-queue queue)))
		     (do ((awakened ()))
			 (()) 
			 (cond (job 
				(caseq (process-job job)
				       (dead
					(setf (processor-queue-length processor)
					      (1- (processor-queue-length processor)))
					(remove-queue job (processor-job-queue processor))
					(cond ((eq job last)	;we just tried the last job
					       (setq all-dead 
						     (and all-dead 
							  (not awakened)))
					       (return all-dead)) 
					      (t (setq job (get-queue queue)))))
				       (awakened
					(setq awakened t)
					(setf (processor-queue-length processor)
					      (1- (processor-queue-length processor)))
					(remove-queue job (processor-job-queue processor))
					(cond ((eq job last)	;we just tried the last job
					       (setq all-wait ())
					       (setq all-dead ())
					       (return ()))	;all dead
					      (t 
					       (setq job
						     (get-queue queue)))))
				       (wait 
					(cond ((eq job last)
					       (setq all-dead 
						     (and all-dead 
							  (not awakened)))
					       (return (not awakened)))
					      (t 
					       (setq job
						     (get-queue queue)))))
				       ((alive locked suicidal)
					(setq all-dead () all-wait ())
					(return ()))))     	;something is alive
			       (t (return t)))))))) ;all dead

;;; Returns ALIVE if JOB is alive

(defun process-job (job)
       (prog2
	(restore-state job)
	(let ((state (job-active job)))
	     (caseq state
		    ((alive locked suicidal)
		     (incf (meter-active-cycles *meter*))
		     (funcall (pop *pc-stack*))
		     (cond ((null *pc-stack*)		;dead
			    (let ((jvd (job-value-dest job)))
				 (cond ((and jvd
					     (eq (value-dest-type jvd) 'empty))
					(push (job-value-dest job) *arg-stack*)
					(setf (job-active job) 'wait)
					(setf (job-waiter job) 'm-wait-value-dest)
					'wait)
				       ((or (and jvd
						 (return-message (job-value-dest job)
								 (top *arg-stack*)
								 (job-dest-id job)))
					    t)
					(let ((jl (job-list job)))
					     (cond (jl
						    (setf (job-list job) (job-list jl))
						    (setf (job-dest-id job) (job-dest-id jl))
						    (setf (job-value-dest job) (job-value-dest jl))
						    (restore-state jl)
						    (setf (job-active job) 'alive)
						    'alive)
						   (t (cond ((closure-expression job)
							     (setf (job-active job) 'ready))
							    (t 
							     (setf (job-active job) 'dead)))
						      'awakened)))))))
			   (t state)))  			;alive
		    (wait
		     (cond ((funcall (job-waiter job))
			    (incf (meter-active-cycles *meter*))
			    (setf (job-active job) 'alive)
			    (cond ((null *pc-stack*)		;dead
				   (cond ((job-value-dest job)
					  (return-message (job-value-dest job)
							  (top *arg-stack*)
							  (job-dest-id job))))
				   (let ((jl (job-list job)))
					(cond (jl
					       (setf (job-list job) (job-list jl))
					       (setf (job-dest-id job) (job-dest-id jl))
					       (setf (job-value-dest job) (job-value-dest jl))
					       (restore-state jl)
					       (setf (job-active job) 'alive)
					       'alive)
					      (t (cond ((closure-expression job)
							(setf (job-active job) 'ready))
						       (t 
							(setf (job-active job) 'dead)))
						 'awakened))))
				  (t 'alive)))  			;alive
			   (t 
			    (incf (meter-wait-cycles *meter*))
			    'wait)))				;alive
		    (dead 'dead)
		    (t (error "Process-job error" (closure-expression job)))))
	(save-state job))))))

(defun return-message (dest value expression)
       (caseq (value-dest-type dest)
	      (processor
	       (let ((job (value-dest-destination dest)))
		    (setf (job-values job)
			  (nconc (job-values job)
				 (ncons (make-return-message 
					 id expression
					 contents value))))))
	      (eager-cell
	       (let ((cell (value-dest-destination dest)))
		    (setf (eager-cell-value cell) value)
		    (setf (eager-cell-full cell) 'full)))
	      (t (error "Bad Return Message Type"))))

(defun multi-schedule (queue processors)
       (do ((l queue (cdr l)))
	   ((null l) ())
	   (multi-schedule-one (car l) () processors)))

(defun multi-schedule-one (job record processors)
  (incf (meter-scheduled-processes *meter*))
  (let ((best
	 (car processors))
	(len (processor-queue-length (car processors))))
       (do ((pr (cdr processors) (cdr pr)))
	   ((null pr)
	    (setf (job-active job) 'alive)
	    (add-queue job
		       (processor-job-queue best))
	    (setf (processor-queue-length best)
		  (1+ (processor-queue-length best)))
	    (cond (record 
		   (setf 
		    (job-closure-processor record)
		    best))))
	   (cond ((< (processor-queue-length (car pr))
		     len)
		  (setq best (car pr)
			len (processor-queue-length (car pr))))))))

(defun run (machine)
       (do ((dead (multi-process machine)
		  (multi-process machine))
	    (n *variable-conflict-window* (1- n))
	    (*time* 1 (1+ *time*)))
 	   (dead (setf (meter-multicycles *meter*) *time*) t)
	   (cond (*keep-load-history*
		  (m-push (current-load) (meter-load-history *meter*))))
 	   (setf (meter-multicycles *meter*) *time*)
	   (cond ((zerop n) (setq *recent-vars* ())))
	   ))

(defun now ()
       *time*)
;;; Environment Stuff

(defun m-assign (var val)
       (do ((l *environment* (cdr l)))
	   ((null l)
	    (push `(,var . ,*self*) *recent-vars*)
	    (set var val))
	   (cond ((eq (caar l)
		      var)
		  (cond ((recent-var-memq (car l) *recent-vars*)
			 (incf (meter-write-conflicts *meter*))
			 (push (car l) *pc-stack*)
			 (push-all `(m-delay ,*read-time*) *pc-stack*)
			 (push 'm-assign-2 *pc-stack*)
			 (push val *arg-stack*)
			 (return ()))
			(t 
			 (push `(, (car l) . ,*self*) *recent-vars*)
			 (setf (cdr (car l))
			       val)
			 (return val)))))))
	   
(defun m-lookup-1 (var)
       (do ((l *environment* (cdr l)))
	   ((null l)
	    (cond ((boundp var)
		   (symeval var))))
	   (cond ((eq (caar l)
		      var)
		  (return (cdr (car l)))))))

(defun m-add-env (var val)
       (push `(,var . ,val) *environment*))

(defun m-add-env-1 (pairs)
       (setq *environment*
	     (append pairs *environment*)))

(defun m-symeval (var)
       (cond ((recent-var-memq var *recent-vars*)
	      (incf (meter-read-conflicts *meter*))
	      (push 'm-symeval-1 *pc-stack*)
	      (push-all `(m-delay ,*read-time*) *pc-stack*))
	     (t 
	      (push `(,var . ,*self*) *recent-vars*)
	      (setf (top *arg-stack*)
		    (symeval var)))))

(defun m-symeval-1 ()
       (setf (top *arg-stack*)
	     (symeval (top *arg-stack*))))

(defun m-symeval-2 ()
       (setf (top *arg-stack*)
	     (cdr (top *arg-stack*))))
;;; Simple Interpreter M-EVAL

(defun m-eval ()
       (let ((expr (top *arg-stack*)))
;	    (print `(evaling ,expr))
	    (cond ((numberp expr))
		  ((null expr))
		  ((eq expr t))
		  ((atom expr)
		   (cond ((zerop *read-time*)
			  (setf (top *arg-stack*) (m-lookup-1 (top *arg-stack*))))
			 (t
			  (let ((var (top *arg-stack*)))
			       (do ((l *environment* (cdr l)))
				   ((null l)
				    (m-symeval var))
				   (cond ((eq (caar l)
					      var)
					  (cond ((recent-var-memq (car l) *recent-vars*)
						 (incf (meter-read-conflicts *meter*))
						 (push 'm-symeval-2 *pc-stack*)
						 (push-all `(m-delay ,*read-time*) *pc-stack*) 
						 (setf (top *arg-stack*) (car l))
						 (return ())
						 )
						(t (setf (top *arg-stack*) (cdr (car l)))
						   (push 
						    `(,(car l) . ,*self*)
						    *recent-vars*)
						   (return ())))))))))
		   (let ((val (top *arg-stack*)))
			(cond ((atom val))
			      ((numberp val))
			      ((eager-cellp val)
			       (cond ((eager-cell-fullp val)
				      (setf (top *arg-stack*)
					    (eager-cell-value val)))
				     (t (m-wait-for-eager-value)))))))
		  ((atom (car expr))
		   (caseq (car expr)
			  (quote (setf (top *arg-stack*)
				       (cadr expr)))
			  ((closure qclosure))
			  (t
			   (let ((fun (get (car expr) 'm-subr)))
			    (cond (fun
				   (m-subr-funcall fun expr))
				  (t 
				   (let ((m
					  (get (car expr) 'macro))
					 (ovaluep *valuep*)) 
					(cond (m
					       (let ((form (funcall m expr)))
						    (rplaca expr (car form))
						    (rplacd expr (cdr form))
						    (setf (top *arg-stack*)
							  expr))
					       (push 'm-eval *pc-stack*))
					      (t
					       (pop *arg-stack*)
					       (cond 
						((getl (car expr) '(expr subr lsubr))
						 (push (car expr) *pc-stack*)
						 (push (length (cdr expr)) *pc-stack*)
						 (push 'm-lisp-call *pc-stack*))
						(t 
						 (cond ((memq ovaluep '(argument in-progn-tail))
							(push *environment* *pc-stack*)
							(push 'm-restore-env *pc-stack*)))
						 (push (car expr) *pc-stack*)
						 (push 'm-apply *pc-stack*)))
					       (push *valuep* *pc-stack*)
					       (push 'm-restore-valuep *pc-stack*)
					       (setq *valuep* 'argument)
					       (do ((l (reverse (cdr expr)) (cdr l)))
						   ((null l) ())
						   (push 'm-stash-arg *pc-stack*)
						   (push 'm-eval *pc-stack*)
						   (push (car l) *arg-stack*)))))))))))
		  (t 
		   (caseq (caar expr)
			  ((lambda closure)
			   (push *environment* *pc-stack*)
			   (push 'm-restore-env *pc-stack*)
			   (push (car expr) *pc-stack*) 
			   (push 'm-apply *pc-stack*)
			   (pop *arg-stack*)
			   (push *valuep* *pc-stack*)
			   (push 'm-restore-valuep *pc-stack*)
			   (setq *valuep* 'argument)
			   (do ((l (reverse (cdr expr)) (cdr l)))
			       ((null l) ())
			       (push 'm-stash-arg *pc-stack*)
			       (push 'm-eval *pc-stack*)
			       (push (car l) *arg-stack*)))
			  (qlambda
			   (push *environment* *pc-stack*)
			   (push 'm-restore-env *pc-stack*)
			   (pop *arg-stack*)
			   (push (cdr expr) *pc-stack*)
			   (push 'm-funcall *pc-stack*)
			   (push (car expr) *arg-stack*)
			   (push 'm-eval *pc-stack*))
			  (qclosure
			   (print 'applying-a-qclosure)
			   (push expr *pc-stack*)
			   (push 'm-qclosure-apply *pc-stack*)
			   (push *valuep* *pc-stack*)
			   (push 'm-restore-valuep *pc-stack*)
			   (setq *valuep* 'argument)
			   (push (cadr (car expr)) *arg-stack*)
			   (push 'm-eval *pc-stack*))
			  (t (push (cdr expr) *arg-stack*)
			     (push 'm-eval *pc-stack*)
			     (push 'm-eval-2 *pc-stack*)
			     (push (car expr) *arg-stack*)
			     (push 'm-eval *pc-stack*)))))))

(defun m-eval-2 ()
       (let ((fun (pop *arg-stack*)))
	    (setf (top *arg-stack*) (cons fun (top *arg-stack*)))
	    t))

(defun m-prognify (form)
       (cond ((null (cdr form)) (car form))
	     (t `(progn . ,form))))

(defun m-funcall ()
       (let ((expr (top *pc-stack*)))
	    (setf (top *pc-stack*) (pop *arg-stack*))
	    (push 'm-apply *pc-stack*)
	    (cond ((tail-recursivep *valuep*)
		   (setq *valuep* 'argument)))
	    (push *valuep* *pc-stack*)
	    (push 'm-restore-valuep *pc-stack*)
	    (setq *valuep* 'argument)
	    (do ((l (reverse expr) (cdr l)))
		((null l) 
		 ())
		(push 'm-stash-arg *pc-stack*)
		(push 'm-eval *pc-stack*)
		(push (car l) *arg-stack*)) ))

(defun m-eval-labels (expr)
       (let ((vars ())
	     (vals ()))
	    (push *valuep* *pc-stack*)
	    (push 'm-restore-valuep *pc-stack*)
	    (setq *valuep* 'argument)
	    (push *environment* *pc-stack*)
	    (push 'm-restore-env *pc-stack*)
	    (do ((l (cadr expr) (cdr l))
		 (var ())(val ()))
		((null l) ())
		(setq var (caar l) val (cadar l))
		(m-add-env var ())
		(push var vars)
		(push val vals))
	    (push `(labels ,(reverse vars) . ,(cddr expr)) *pc-stack*)
	    (push 'm-apply *pc-stack*)
	    (pop *arg-stack*)
	    (do ((l vals (cdr l)))
		((null l) ())
		(push 'm-stash-arg *pc-stack*)
		(push 'm-eval *pc-stack*)
		(push (car l) *arg-stack*))))

(defun m-qlambda ()
       (let ((val (top *arg-stack*)))
	    (cond 
	     ((eq val 'eager)
	      (let ((x (top *pc-stack*)))
		   (setf (top *pc-stack*) 'm-flush-top-arg-stack)
		   (push x *pc-stack*))
	      (setq *valuep* ())
	      (setf (top *arg-stack*)(pop *pc-stack*))
	      (let ((cells
		     (m-eager-evqlambda)))
		   (push (top *arg-stack*) *pc-stack*)
		   (push 'm-apply *pc-stack*)
		   (push-all cells *evarg-stack*)
		   ))
	     (val 
	      (setf (top *arg-stack*) (pop *pc-stack*))
	      (m-evqlambda))
	     (t
	      (setf (top *arg-stack*)
		    `(closure (lambda .,(cddr (pop *pc-stack*)))
				   ,*environment*))))))

(defun m-restore-lock ()
       (caseq (job-active *self*)
	      (suicidal (setf (job-active *self*) 'dead))
	      (t (setf (job-waiter *self*) (pop *pc-stack*))
	         (setf (job-active *self*) (pop *pc-stack*)))))

(defun m-set-lock ()
       (setf (job-active *self*) 'locked))

(defun m-expand-caseq (form)
       (let ((var (gensym)))
	    `((lambda (,var)
		      (cond . ,(mapcar 
				#'(lambda (q)
					  (cond 
					   ((eq (car q) 't)
					    `(t .,(cdr q)))
					   ((or (atom (car q))
						(numberp (car q)))
					   `((equal ,var (quote ,(car q)))
					     . ,(cdr q)))
					   (t 
					    `((member ,var (quote ,(car q)))
					      . ,(cdr q)))))
				(cddr form))))
	      ,(cadr form))))
;;; M-SUBR's for Everything

(defun (setq m-subr m-subr) (expr)
       (push (cadr expr) *pc-stack*)
       (push 'm-evsetq *pc-stack*)
       (push 'm-eval *pc-stack*)
       (setf (top *arg-stack*) (caddr expr)))

(defun (lambda m-subr m-subr) (expr)
	(setf (top *arg-stack*)
	      `(closure ,expr ,*environment*)))

(defun (qlambda m-subr m-subr) (expr)
       (push *valuep* *pc-stack*)
       (push 'm-restore-valuep *pc-stack*)
       (setq *valuep* 'argument)
       (setf (top *arg-stack*) (cadr expr))
       (push expr *pc-stack*)
       (push 'm-qlambda *pc-stack*)
       (push 'm-eval *pc-stack*))

(defun (cond m-subr m-subr) (expr)
       (push *valuep* *pc-stack*)
       (push (cdr expr) *pc-stack*)
       (push 'm-evcond *pc-stack*)
       (setq *valuep* 'argument)
       (setf (top *arg-stack*) (car (cadr expr)))
       (push 'm-eval *pc-stack*))

(defun (progn m-subr m-subr) (expr)
	(push *valuep* *pc-stack*)
	(pop *arg-stack*)
	(setq *valuep* ())
	(push expr *pc-stack*)
	(push 'm-evprogn *pc-stack*))

(defun (or m-subr m-subr) (expr)
       (push *valuep* *pc-stack*)
       (push (cddr expr) *pc-stack*)
       (push 'm-evor *pc-stack*)
       (setf (top *arg-stack*) (cadr expr))
       (setq *valuep* 'argument)
       (push 'm-eval *pc-stack*))

(defun (and m-subr m-subr) (expr)
       (push *valuep* *pc-stack*)
       (push (cddr expr) *pc-stack*)
       (push 'm-evand *pc-stack*)
       (setf (top *arg-stack*) (cadr expr))
       (setq *valuep* 'argument)
       (push 'm-eval *pc-stack*)) 

(defun (not m-subr m-subr) (expr)
       (push *valuep* *pc-stack*)
       (push 'm-evnot *pc-stack*)
       (push 'm-eval *pc-stack*)
       (setq *valuep* 'argument)
       (setf (top *arg-stack*) (cadr expr)))

(defun (do m-subr m-subr)(expr)
       (push *environment* *pc-stack*)
       (push 'm-restore-env *pc-stack*)
       (push 'm-restore-catch-thread-1 *pc-stack*)
       (let ((*pc-stack* *pc-stack*)
	     (*arg-stack* *arg-stack*))
	    (push 'internal-do-tag *arg-stack*)
	    (push () *pc-stack*)
	    (m-catch))
       (pop *arg-stack*)
       (let ((vars
	      (mapcar #'car (cadr expr))))
	    (push `(,vars
		    ,(mapcar #'caddr (cadr expr))
		    ,(car (caddr expr))
		    ,(m-prognify (cdr (caddr expr)))
		    ,(m-prognify (cdddr expr))
		    ,*valuep*)
		  *pc-stack*)
	    (m-do-step-1 (mapcar #'cadr (cadr expr)))
	    ))

(defun (return m-subr m-subr) (expr)
       (push 'm-throw *pc-stack*)
       (push 'internal-do-tag  *evarg-stack*)
       (setf (top *arg-stack*) (cadr expr))
       (push 'm-eval *pc-stack*))

(defun (catch m-subr m-subr) (expr)
       (push 'm-restore-catch-thread-1 *pc-stack*)
       (push 'm-restore-catch-thread *pc-stack*)
       (push 'm-do-unwind-protect-cleanups *pc-stack*)
       (push 'm-eval *pc-stack*)
       (setf (top *arg-stack*) (caddr expr))
       (push 'm-catch *pc-stack*)
       (push (cadr expr) *arg-stack*)
       (push 'm-eval *pc-stack*))

(defun (qcatch m-subr m-subr) (expr)
       (push 'm-restore-catch-thread-1 *pc-stack*)
       (push 'm-restore-catch-thread *pc-stack*)
       (push 'm-do-unwind-protect-cleanups *pc-stack*)
       (push 'm-qcatch *pc-stack*)
       (push 'm-eval *pc-stack*)
       (setf (top *arg-stack*) (caddr expr))
       (push 'm-catch *pc-stack*)
       (push (cadr expr) *arg-stack*)
       (push 'm-eval *pc-stack*))

(defun (throw m-subr m-subr) (expr)
       (push 'm-throw *pc-stack*)
       (setf (top *arg-stack*) (caddr expr))
       (push 'm-eval *pc-stack*)
       (push 'm-stash-arg *pc-stack*)
       (push (cadr expr) *arg-stack*)
       (push 'm-eval *pc-stack*))

(defun (unwind-protect m-subr m-subr) (expr)
       (push (job-waiter *self*) *pc-stack*)
       (push (job-active *self*) *pc-stack*)
       (push 'm-restore-lock *pc-stack*)
       (push (caddr expr) *arg-stack*)
       (push 'm-eval *pc-stack*)
       (push 'm-set-lock *pc-stack*)
       (push 'm-flush-top-arg-stack *pc-stack*)
       (push (cadr expr) *arg-stack*)
       (setq *valuep* 'argument)
       (push 'm-eval *pc-stack*)
       (cond (*catch-thread*
	      (m-add-unwind-protects
	       *self* *environment* 
	       (caddr expr) *catch-thread*))))


(defun (qlet m-subr m-subr) (expr)
       (let ((nexpr (make-internal-qlet 
		     (mapcar #'car (caddr expr))
		     (mapcar #'cadr (caddr expr))
		     (cdddr expr))))
	    (push nexpr *pc-stack*)
	    (setf (top *arg-stack*) nexpr))
       (push 'm-qlet-apply *pc-stack*)
       (push *valuep* *pc-stack*)
       (push 'm-restore-valuep *pc-stack*)
       (setq *valuep* 'argument)
       (push (cadr expr) *arg-stack*)
       (push 'm-eval *pc-stack*))

(defun (funcall m-subr m-subr)(expr)
       (push *environment* *pc-stack*)
       (push 'm-restore-env *pc-stack*)
       (pop *arg-stack*)
       (push (cddr expr) *pc-stack*)
       (push 'm-funcall *pc-stack*)
       (push (cadr expr) *arg-stack*)
       (push 'm-eval *pc-stack*))

(defun (m-eval m-subr m-subr)(expr)
       (setf (top *arg-stack*) (cadr (top *arg-stack*)))
       (push 'm-eval *pc-stack*)
       (push 'm-eval *pc-stack*))

(defun (labels m-subr m-subr) (expr)
       (m-eval-labels expr))

(defun (caseq m-subr m-subr) (expr)
       (setf (top *arg-stack*)
	     (m-expand-caseq (top *arg-stack*)))
       (push 'm-eval *pc-stack*))

(defun (if-lockp m-subr m-subr) (expr)
       (push (cadddr expr) *pc-stack*)
       (push (caddr expr) *pc-stack*)
       (push 'm-if-lockp *pc-stack*)
       (push (cadr expr) *arg-stack*)
       (push 'm-eval *pc-stack*))
;;; Simple Interpreter M-APPLY

(defun m-apply ()
       (let ((new-valuep *valuep*))
	    (let ((fun (pop *pc-stack*)))
		 (let ((val
			(cond ((atom fun)
			       (setq new-valuep 'tail-recursive)
			       (let ((val 
				      (m-lookup-1 fun)))
				    (prog1
				     (cond (val)
					   (t 
					    (setq *environment* ())
					    (get fun 'm-expr))))))
			      (t fun))))
		      (cond ((eager-cellp val)
			     (cond ((eager-cell-fullp val)
				    (setq val
					  (eager-cell-value val)))
				   (t (push new-valuep *pc-stack*)
				      (push fun *pc-stack*)
				      (push val *arg-stack*)
				      (push 'm-apply2 *pc-stack*)
				      (m-wait-for-eager-value))))
			    ((eq (car val) 'qlambda)
			     (push *valuep* *pc-stack*)
			     (push fun *pc-stack*)
			     (push 'm-apply2 *pc-stack*)
			     (push (cadr val) *arg-stack*)
			     (push val *pc-stack*)
			     (push 'm-qlambda *pc-stack*)
			     (push 'm-eval *pc-stack*))
			    (t (m-apply1 val fun new-valuep)))))))

(defun m-apply2 ()
       (m-apply1 (pop *arg-stack*) (pop *pc-stack*) (pop *pc-stack*)))

(defun m-apply1 (val fun new-valuep)
 (let ((args ())
       (labels ())
       (qclosure-state ())
       (job *self*)
       (running-eager-closurep ())
       (eager-closurep ())
       (new-eager-closurep ())
       (cells ())
       (body ()))
       (caseq (car val)
	      (lambda
	       (setq args (cadr val)
		     body (cddr val)))
	      (labels
	       (setq labels t)
	       (setq args (cadr val)
		     body (cddr val)))
	      (qclosure
	       (let* ((closure-job (qclosure-job-record val))
		      (job1
		       (job-closure-job closure-job))
		      (argument-type (job-closure-argument-type closure-job)))
		    (setq qclosure-state (job-active job1))
		    (cond 
		     ((eq qclosure-state 'ready)
		      (cond
		       ((eq argument-type 'normal)
			(let ((record
			       (qclosure-job-record val)))
			     (multi-schedule-one 
			      job1 record
			      (machine-processors *machine*))))
		       ((eq argument-type 'new-eager)
			(setq eager-closurep t)
			(setq new-eager-closurep t)
			(setf (job-closure-argument-type closure-job)
			      'eager) 
			(let ((record
			       (qclosure-job-record val)))
			     (multi-schedule-one 
			      job1 record
			      (machine-processors *machine*))))
		       (t
			(setq cells (job-closure-eager-cells closure-job))
			(setq running-eager-closurep t)
			(setf (job-closure-argument-type closure-job)
			      'normal))))
		     ((eq (job-closure-argument-type closure-job)
			  'eager)
		      (setq eager-closurep t)
		      (setq cells (job-closure-eager-cells closure-job))
		      (setq running-eager-closurep t)
		      (setf (job-closure-argument-type closure-job)
			    'normal))
		     (t (let ((job2 
			       (copy-job job1)))
			     (setf (job-list job2) ())
			     (m-add-job-list job1 job2)
			     (setq job1 job2))))
		    (setq job job1
			  args (cadr (cadr (closure-expression job1)))
			  body (cddr (cadr (closure-expression job1))))
		    (cond ((tail-recursivep *valuep*)
			   (setf (job-value-dest *self*) ())))
		    (cond (eager-closurep
			   (cond (running-eager-closurep
				  (cond ((not (tail-recursivep *valuep*))
					 (setf (job-active *self*) 'wait)
					 (setf (job-waiter *self*) 'm-wait-closure) 
					 (setf (job-dest-id job1) job1)
					 (setf (value-dest-type (job-value-dest job1))
					       'processor)
					 (setf (value-dest-destination (job-value-dest job1))
					       *self*)))
				  (push job1 *pc-stack*))
				 (new-eager-closurep
				  (push-all
				   (caddr (closure-expression job1))
				   (environment job1))
				  (push 'no-value *arg-stack*))))
			  (t (push-all
			      (caddr (closure-expression job1))
			      (environment job1))
			     (cond 
			      ((null *valuep*)
			       (push 'no-value *arg-stack*)
			       (setf (job-value-dest job1) ()))
			      ((tail-recursivep *valuep*))
			      (t (setf (job-active *self*) 'wait)
				 (setf (job-waiter *self*) 'm-wait-closure) 
				 (setf (job-dest-id job1) job1)
				 (setf (job-value-dest job1) 
				       (make-value-dest
					type 'processor
					destination *self*))
				 (push job1 *pc-stack*)))))))
	      (closure
	       (cond ((eq (caddr val) *environment*))
		     (t (push *environment* *pc-stack*)
			(push 'm-restore-env *pc-stack*)
			(setq *environment* (caddr val))))
	       (setq args (cadr (cadr val))
		     body (cddr (cadr val)))
	       (cadr val))
	      (t (let ((*function* fun))
              	      (error "Bad Function" fun)))) 
       (do ((var (reverse args) (cdr var))
	    (l ()))
	   ((null var)
	    (setq *valuep* new-valuep)
	    (cond ((eq job *self*)
		   (cond (labels
			  (mapc #'(lambda (x)
					  (m-assign (car x) (cdr x)))
				l))
			 (t (push-all l *environment*)))
		   (cond ((null (cdr body))
			  (push (car body) *arg-stack*)
			  (push 'm-eval *pc-stack*))
			 (t 
			  (push *valuep* *pc-stack*)
			  (push `(progn . ,body) *pc-stack*)
			  (push 'm-evprogn *pc-stack*))))
		  (running-eager-closurep
		   (mapc #'(lambda (cell value)
				   (setf (eager-cell-full cell) 'full)
				   (setf (eager-cell-value cell) (cdr value)))
			 cells l))
		  (t 
		   (push-all l (environment job))
		   (cond ((null (cdr body))
			  (setf (arg-stack job) (ncons (car body)))
			  (setf (pc-stack job) (ncons 'm-eval)))
			 (t (setf (pc-stack job) `(m-evprogn (progn . ,body) 
							     ,*valuep*))
			    (setf (arg-stack job) ())))
		   (cond ((not (zerop *process-creation-time*))
			  (m-push *process-creation-time* (pc-stack job))
			  (m-push 'm-delay (pc-stack job))))) )
	    ) 
	   (push `(,(car var) . ,(pop *evarg-stack*)) l)))) 

(defun m-lisp-call ()
       (let ((vals (rfirst-n (pop *pc-stack*) *evarg-stack*)))
	    (push (apply (pop *pc-stack*) vals)
		  *arg-stack*) ))

(defun m-restore-env ()
       (setq *environment* (pop *pc-stack*)))

(defun m-restore-catch-thread ()
       (and *catch-thread*
	    (kill-all-closure-jobs 
	     (catch-record-jobs *catch-thread*))))

(defun m-restore-catch-thread-1 ()
       (and *catch-thread*
	    (setq *catch-thread* (catch-record-catch-thread *catch-thread*))))

(defun m-stash-arg ()
       (push (pop *arg-stack*) *evarg-stack*))

(defun m-sleep (n)
 (push n *pc-stack*)
 (push 'm-delay *pc-stack*))

(defun m-delay ()
       (let ((n (top *pc-stack*)))
	    (cond ((zerop n)
		   (pop *pc-stack*))
		  (t (decf (top *pc-stack*))
		     (push 'm-delay *pc-stack*)))))

(defun m-add-catch-threads (rec th)
       (do ((th th (catch-record-catch-thread th)))
	   ((null th) t)
	   (m-push rec
		   (catch-record-jobs th))))

(defun m-add-unwind-protects (job environment form th)
       (do ((th th (catch-record-catch-thread th)))
	   ((null th) t)
	   (m-push (make-unwind-protect-cleanup
		    job job
		    environment (copy-environment environment)
		    form form)
		   (catch-record-cleanups th))))
;;; COND, OR, AND, NOT

(defun m-evcond ()
       (let ((val (top *arg-stack*)))
	    (cond (val
		   (let ((arm (car (pop *pc-stack*))))
			(setf *valuep* (pop *pc-stack*))
			(cond ((cdr arm)
			       (pop *arg-stack*)
			       (cond ((null (cddr arm))
				      (push (cadr arm) *arg-stack*)
				      (push 'm-eval *pc-stack*))
				     (t  
				      (push *valuep* *pc-stack*)
				      (push `(progn . ,(cdr arm)) *pc-stack*)
				      (push 'm-evprogn *pc-stack*)))))))
		  (t (let ((arms (pop *pc-stack*)))
			  (cond (arms 
				 (pop *arg-stack*)
				 (push (cdr arms) *pc-stack*)
				 (push 'm-evcond *pc-stack*)
				 (push (car (cadr arms)) *arg-stack*)
				 (push 'm-eval *pc-stack*))
				(t (setf *valuep* (pop *pc-stack*)))))))))

(defun m-evor ()
       (let ((val (top *arg-stack*)))
	    (cond (val
		   (setf *valuep* (pop *pc-stack*))
		   (pop *pc-stack*))
		  (t (let ((arms (pop *pc-stack*)))
			  (cond (arms
				 (pop *arg-stack*)
				 (push (cdr arms) *pc-stack*)
				 (push 'm-evor *pc-stack*)
				 (push (car arms) *arg-stack*)
				 (push 'm-eval *pc-stack*))
				(t (setf *valuep* (pop *pc-stack*)))))))))


(defun m-evand ()
       (let ((val (top *arg-stack*)))
	    (cond ((not val)
		   (setf *valuep* (pop *pc-stack*))
		   (pop *pc-stack*))
		  (t (let ((arms (pop *pc-stack*)))
			  (cond (arms
				 (pop *arg-stack*)
				 (push (cdr arms) *pc-stack*)
				 (push 'm-evand *pc-stack*)
				 (push (car arms) *arg-stack*)
				 (push 'm-eval *pc-stack*))
				(t (setf *valuep* (pop *pc-stack*)))))))))

(defun m-evnot ()
       (setf *valuep* (pop *pc-stack*))
       (setf (top *arg-stack*) (not (top *arg-stack*))))
;;; PROGN

(defun m-evprogn ()
       (let ((form (pop *pc-stack*)))
	    (cond ((cddr form)
		   (setq *valuep* 'in-progn-tail)
		   (push `(progn . ,(cddr form)) *pc-stack*)
		   (push 'm-evprogn-1 *pc-stack*))
		  (t (setq *valuep* (pop *pc-stack*))))
	    (push (cadr form) *arg-stack*)
	    (push 'm-eval *pc-stack*)
	    )))

(defun m-evprogn-1 ()
       (pop *arg-stack*)
       (let ((form (pop *pc-stack*)))
	    (cond ((cddr form)
		   (setq *valuep* 'in-progn-tail)
		   (push `(progn . ,(cddr form)) *pc-stack*)
		   (push 'm-evprogn-1 *pc-stack*))
		  (t (setq *valuep* (pop *pc-stack*))))
	    (push (cadr form) *arg-stack*)
	    (push 'm-eval *pc-stack*)
	    )))
;;; SETQ

(defun m-evsetq ()
       (cond ((zerop *write-time*)
	      (m-assign
	       (pop *pc-stack*)
	       (top *arg-stack*)))
	     (t (cond ((recent-var-memq (top *pc-stack*)
			     *recent-vars*)
		       (incf (meter-write-conflicts *meter*))
		       (push 'm-assign-1 *pc-stack*)
		       (push-all `(m-delay ,*write-time*)
				 *pc-stack*))
		      (t 
		       (m-assign
			(pop *pc-stack*)
			(top *arg-stack*)))))))

(defun m-assign-1 ()
       (m-assign
	(pop *pc-stack*)
	(top *arg-stack*)))

(defun m-assign-2 ()
       (setf (cdr (pop *pc-stack*)) (top *arg-stack*)))
;;; QLAMBDA

(defun m-evqlambda ()
       (incf (meter-processes *meter*))
       (let ((expr (top *arg-stack*))
	     (env (copy *environment*)))
	    (let ((expression `(closure ,expr ,env))
		  (body (m-prognify (cdddr expr)))
		  (cexpression `(closure (lambda ,(caddr expr)
						 .,(cdddr expr))
					 ,env)))
		 (let ((record
			(make-job-closure
			 job
			 (make-job
			  closure-expression cexpression
			  job-expression expression
			  job-dest-id expr
			  catch-thread *catch-thread*
			  arg-stack (ncons body)
			  pc-stack (ncons 'm-eval)
			  job-waiter 'm-closure-waiter
			  job-active 'ready))))
		      (setf (top *arg-stack*)
			    (make-qclosure 
			     (caddr (top *arg-stack*)) 
			     record))
		      (cond (*catch-thread*
			     (m-add-catch-threads 
			      record *catch-thread*)
			     record)
			     )))))

(defun m-eager-evqlambda ()
       (incf (meter-processes *meter*))
       (let ((expr (top *arg-stack*))
	     (env (copy-environment *environment*)))
	    (let ((expression `(closure ,expr ,env))
		  (body (m-prognify (cdddr expr)))
		  (cells (mapcar #'(lambda (())
					   (make-eager-cell))
				 (caddr expr)))
		  (cexpression `(closure (lambda ,(caddr expr)
						 .,(cdddr expr))
					 ,env)))
		 (let ((record
			(make-job-closure
			 argument-type 'new-eager
			 eager-cells cells
			 job
			 (make-job
			  closure-expression cexpression
			  job-expression expression
			  job-dest-id expr
			  catch-thread *catch-thread*
			  arg-stack (ncons body)
			  job-value-dest
			  (make-value-dest
			   type 'empty)
			  pc-stack (ncons 'm-eval)
			  job-waiter 'm-closure-waiter
			  job-active 'ready))))
		      (setf (top *arg-stack*)
			    (make-qclosure 
			     (caddr (top *arg-stack*)) 
			     record))
		      (cond (*catch-thread*
			     (m-add-catch-threads 
			      record *catch-thread*)
			     record)
			     )
		      cells))))

;;; Form is of the form (internal-qlet vars exprs body)

(defun m-qlet-apply ()
       (let ((form (pop *pc-stack*))
	     (multip (pop *arg-stack*)))
	    (cond (multip
		   (let ((destinations
			  (cond ((eq multip 'eager)
				 (push 'm-restore-catch-thread *pc-stack*)
				 (let ((*pc-stack* *pc-stack*)
				       (*arg-stack* *arg-stack*))
				      (push (ncons ()) *arg-stack*)
				      (push () *pc-stack*)
				      (m-catch))
				 (mapcar #'(lambda (())
						   (make-value-dest
						    type 'eager-cell
						    destination (make-eager-cell)))
					 (internal-qlet-vars form)))
				(t (mapcar #'(lambda (())
						     (make-value-dest
						      type 'processor
						      destination *self*))
					   (internal-qlet-vars form))))))
			(mapc #'(lambda (x dest)
					(incf (meter-processes *meter*))
					(let ((cexpression
					       `(closure
						 (lambda ()
							 ,x)
						 ,*environment*)))
					     (let ((expression `(,cexpression)))
						  (let ((job 
							 (make-job
							  job-expression
							  cexpression
							  closure-expression
							  cexpression
							  catch-thread *catch-thread*
							  arg-stack (ncons expression)
							  pc-stack 
							  (cond 
							   ((not (zerop *process-creation-time*))
							    `(m-delay ,*process-creation-time* m-eval))
							   (t (ncons 'm-eval)))
							  job-dest-id x
							  job-value-dest dest
							  job-active 'ready)))
						       (cond (*catch-thread*
							      (m-add-catch-threads 
							       (make-job-closure job job)
							       *catch-thread*)))
						       (multi-schedule-one
							job () 
							(machine-processors *machine*))))))
			      (internal-qlet-exprs form) destinations)
			(cond ((eq multip 'eager) 
			       (push 
				`(lambda ,(internal-qlet-vars form)
					 .,(internal-qlet-body form))
				*pc-stack*)
			       (push 'm-apply *pc-stack*)
			       (push-all
				(mapcar 
				 #'(lambda (x)
					   (value-dest-destination x))
				 (reverse destinations))
				*evarg-stack*))
			      (t (setf (job-active *self*) 'wait)
				 (setf (job-waiter *self*) 'm-wait-for-qlet-messages)
				 (push form *pc-stack*)))))
		  (t 
		   (setf (top *arg-stack*)
			 `((lambda ,(internal-qlet-vars form)
				   .,(internal-qlet-body form))
			   .,(internal-qlet-exprs form)))
		   (push 'm-eval *pc-stack*)))))

(defun m-qclosure-apply ()
       (let ((form (pop *pc-stack*))
	     (multip (pop *arg-stack*)))
	    (cond (multip
		   (let ((destinations
			  (cond ((eq multip 'eager)
				 (push 'm-restore-catch-thread *pc-stack*)
				 (let ((*pc-stack* *pc-stack*)
				       (*arg-stack* *arg-stack*))
				      (push (ncons ()) *arg-stack*)
				      (push () *pc-stack*)
				      (m-catch))
				 (mapcar #'(lambda (())
						   (make-value-dest
						    type 'eager-cell
						    destination (make-eager-cell)))
					 (cdr form)))
				(t (mapcar #'(lambda (())
						     (make-value-dest
						      type 'processor
						      destination *self*))
					   (cdr form))))))
			(mapc #'(lambda (x dest)
					(incf (meter-processes *meter*))
					(let ((cexpression
					       `(closure
						 (lambda ()
							 ,x)
						 ,*environment*)))
					     (let ((expression `(,cexpression)))
						  (let ((job 
							 (make-job
							  job-expression
							  cexpression
							  closure-expression
							  cexpression
							  catch-thread *catch-thread*
							  arg-stack (ncons expression)
							  pc-stack 
							  (cond 
							   ((not (zerop *process-creation-time*))
							    `(m-delay ,*process-creation-time* m-eval))
							   (t (ncons 'm-eval)))
							  job-dest-id x
							  job-value-dest dest
							  job-active 'ready)))
						       (cond (*catch-thread*
							      (m-add-catch-threads 
							       (make-job-closure job job)
							       *catch-thread*)))
						       (multi-schedule-one
							job () 
							(machine-processors *machine*))))))
			      (cdr form) destinations)
			(cond ((eq multip 'eager) 
			       (push 
				`(lambda .,(cddr (car form)))
				*pc-stack*)
			       (push 'm-apply *pc-stack*)
			       (push-all
				(mapcar 
				 #'(lambda (x)
					   (value-dest-destination x))
				 (reverse destinations))
				*evarg-stack*))
			      (t (setf (job-active *self*) 'wait)
				 (setf (job-waiter *self*) 'm-wait-for-qclosure-messages)
				 (push form *pc-stack*)))))
		  (t 
		   (setf (top *arg-stack*)
			      `((lambda .,(cddr (car form))) .,(cdr form)))
		   (push 'm-eval *pc-stack*)))))

(defun m-wait-for-qlet-messages ()
       (cond ((= 
	       (length (cadr (top *pc-stack*)))
	       (length (job-values *self*)))
	      (let ((form (pop *arg-stack*))
		    (messages (job-values *self*))
		    (not-all-here ()))
		   (let ((args
			  (mapcar #'(lambda (x)
					    (let ((q (find-message x messages)))
						 (cond (q 
							(return-message-contents 
							 q))
						       (t (setq not-all-here t)))))
				  (reverse (internal-qlet-exprs form)))))
			(cond (not-all-here ())
			      (t (push-all args *evarg-stack*)
				 (setf (top *pc-stack*)
				       `(lambda ,(internal-qlet-vars form)
						.,(internal-qlet-body form)))
				 (push 'm-apply *pc-stack*)
				 (setf (job-values *self*) 
				       (mapcan 
					#'(lambda (x) 
						  (cond ((memq (return-message-id x) 
							       (internal-qlet-exprs form)) ())
							(t `(,x)))) (job-values *self*)))
				 t)))))))

(defun m-wait-for-messages ()
       (cond ((= 
	       (length (cdr (top *pc-stack*)))
	       (length (job-values *self*)))
	      (let ((form (pop *arg-stack*))
		    (messages (job-values *self*))
		    (not-all-here ()))
		   (let ((args
			  (mapcar #'(lambda (x)
					    (let ((q (find-message x messages)))
						 (cond (q 
							(return-message-contents 
							 q))
						       (t (setq not-all-here t)))))
				  (reverse (cdr form)))))
			(cond (not-all-here ())
			      (t (push-all args *evarg-stack*)
				 (setf (top *pc-stack*)
				       `(lambda .,(cddr (car form))))
				 (push 'm-apply *pc-stack*)
				 (setf (job-values *self*) 
				       (mapcan 
					#'(lambda (x) 
						  (cond ((memq (return-message-id x) 
							       (cdr form)) ())
							(t `(,x)))) (job-values *self*)))
				 t)))))))

(defun m-wait-closure ()
 (let ((messages (job-values *self*)))
      (cond ((null messages) ())
	    (t (let* ((message-id (pop *pc-stack*))
		      (q (find-message message-id messages)))
		     (cond (q
			    (push (return-message-contents q) *arg-stack*)
			    (setf (job-values *self*) 
				  (mapcan 
				   #'(lambda (x) 
					     (cond ((eq (return-message-id x) 
							message-id) ())
						   (t `(,x)))) (job-values *self*)))
			    t)))))))

(defun m-null-wait () ())

;;; Job closures run this to see if there is a message to process
(defun m-closure-waiter ()
       (let ((messages (job-values *self*)))
	    (cond ((null messages) ())
		  (t 
		   (push *environment* *pc-stack*)
		   (push 'm-restore-env *pc-stack*)
		   (push (closure-expression *self*) *pc-stack*)
		   (push 'm-apply *pc-stack*)
		   (do ((messages (car messages) (cdr messages)))
			 ((null messages) (m-pop (job-values *self*)))
			 (push 'm-stash-arg *pc-stack*)
			 (push (car messages) *arg-stack*)
			 (push 'm-eval *pc-stack*))
		     t))))

(defun m-qcatch-waiter ()
       (do ((jobs 
             (catch-record-jobs *catch-thread*)
	     (cdr jobs)))
	   ((null jobs) 
	    t)
	   (cond ((or (memq 
		       (job-active (job-closure-job (car jobs)))
		       '(alive wait locked suicidal))
		      (job-list (car jobs)))
		  (return ())))))

(defun m-wait-for-eager-value ()
       (setf (job-active *self*) 'wait)
       (setf (job-waiter *self*) 'm-wait-for-eager-cell))

(defun m-wait-for-eager-cell ()
       (cond ((eager-cell-fullp (top *arg-stack*))
	      (setf (top *arg-stack*)
		    (eager-cell-value (top *arg-stack*)))
	      t)))

(defun m-wait-value-dest ()
       (cond ((not 
	       (eq 
		(value-dest-type (top *arg-stack*))
		   'empty))
	      (pop *arg-stack*)
	      t)))

(defun suspend-process (&optional (p *self*))
       (cond ((and (not (atom p))
		   (eq 'qclosure (car p)))
	      (let ((job
		     (job-closure-job
		      (qclosure-job-record p))))
		   (cond ((eq job *self*)
			  (push (job-active job) *pc-stack*)
			  (push (job-waiter job) *pc-stack*)
			  (setf (job-active job) 'wait)
			  (setf (job-waiter job) 'm-null-wait)
			  t)
			 (t (m-push (job-active job) (pc-stack job))
			    (m-push (job-waiter job) (pc-stack job))
			    (setf (job-active job) 'wait)
			    (setf (job-waiter job) 'm-null-wait)
			    t))))
       (t (setf (job-active p) 'wait)
	  (setf (job-waiter p) 'm-null-wait)
	  t)))

(defun resume-process (p)
       (cond ((and (not (atom p))
		   (eq 'qclosure (car p)))
	      (let ((job
		     (job-closure-job
		      (qclosure-job-record p))))
		   (setf (job-waiter job) (m-pop (pc-stack job)))
		   (setf (job-active job) (m-pop (pc-stack job)))
		   t))))

;;; Do not return a value!

(defun no-return-value ()
       (setf (job-value-dest *self*) ())
       t)

(defun m-unwind-protect-signal-done ()
       (setf (unwind-protect-waiter-valid (pop *pc-stack*)) t) 
       (setf (job-value-dest *self*) ()))

(defun m-unwind-protect-waiter ()
       (let ((waits (top *pc-stack*)))
	    (setq waits
		  (mapcan #'(lambda (q)
				    (cond ((unwind-protect-waiter-valid q) ())
					  (t (ncons q))))
			  waits))
	    (cond ((null waits) (pop *pc-stack*) t)
		  (t (setf (top *pc-stack*) waits)
		     ()))))
;;; CATCH/THROW

(defun m-catch ()
       (let ((tag (pop *arg-stack*)))
	    (setq *valuep* 'argument)
	    (setq *catch-thread*
		  (make-catch-record
		   tag tag
		   job *self*
		   arg-stack *arg-stack*
		   pc-stack *pc-stack*
		   evarg-stack *evarg-stack*
		   environment *environment*
		   job-list (job-list *self*)
		   job-values (job-values *self*)
		   valuep *valuep*
		   catch-thread *catch-thread*))
	    ))

(defun m-qcatch ()
       (cond ((null (catch-record-jobs *catch-thread*)))
	     (t (setf (job-active *self*) 'wait)
		(setf (job-waiter *self*) 'm-qcatch-waiter))))

(defun m-throw ()
       (let ((tag (pop *evarg-stack*)))
	    (do ((th *catch-thread*
		     (catch-record-catch-thread th)))
		((null th)
		 (let ((*tag* tag))
		      (error "No CATCH for this tag" tag)))
		(cond ((eq tag (catch-record-tag th))
		       (let ((val (top *arg-stack*))
			     (job (catch-record-job th)))
			    (cond ((eq *self* job)
				   (catch-restore-self th)
				   (pop *pc-stack*)
				   (setf (top *arg-stack*) val))
				  (t 
 				   (catch-restore-state job th)
				   (m-pop (pc-stack job))
				   (setf (top (arg-stack job)) val)
				   (caseq (job-active *self*)
					  (locked 
					   (setf (job-active *self*) 'suicidal))
					  (suicidal)
					  (t (setf (job-active *self*) 'dead)))
				   (caseq (job-active job)
					  ((alive locked suicidal))
					  (t (setf (job-active job) 'alive)))))
			    (return t)))))))

(defun m-do-unwind-protect-cleanups ()
       (do ((cleanups 
             (reverse (catch-record-cleanups *catch-thread*))
	     (cdr cleanups))
	    (jobs-seen ())
	    (job ())
	    (waiters ()))
	   ((null cleanups)
	    (let ((cleanups (catch-record-cleanups *catch-thread*)))
		 (do ((th (catch-record-catch-thread *catch-thread*)
			  (catch-record-catch-thread th))
		      (cl ()))
		     ((null th) t)
		     (setq cl (catch-record-cleanups th))
		     (setf (catch-record-cleanups th)
			   (delete-em-all cleanups cl))))
;	    (setq *catch-thread* 
;		  (catch-record-catch-thread *catch-thread*))
	    (and *catch-thread*
		 (setf (catch-record-cleanups *catch-thread*) ()))
	    (cond (waiters
		   (setf (job-active *self*) 'wait)
		   (push waiters *pc-stack*)
		   (setf (job-waiter *self*) 'm-unwind-protect-waiter))))
	   ----
	   (setq job (unwind-protect-cleanup-job (car cleanups)))
	   (push (make-unwind-protect-waiter) waiters)
	   (cond ((not (memq job jobs-seen))
		  (setf (job-active job) 'locked)
		  (push job jobs-seen)
		  (setf (pc-stack job) `(m-restore-lock ,(job-active job)))
		  (setf (arg-stack job) ())))
	   (push-all`(m-restore-env 
		      ,(unwind-protect-cleanup-environment (car cleanups))
		      m-eval m-unwind-protect-signal-done
		      ,(car waiters) m-flush-top-arg-stack)
		     (pc-stack job))
	   (m-push (unwind-protect-cleanup-form (car cleanups))
		   (arg-stack job))
	   ---
	   ))

;;; DO

;;; On PC-STACK:
;;;	((<vars><steppers><test-form><result-form><body><old-valuep>) ...)
;;; On EVARG-STACK:
;;;	(val1 val2...)

(defmacro do-vars (l)
	  `(car ,l))
(defmacro do-steppers (l)
	  `(cadr ,l))
(defmacro do-test-form (l)
	  `(caddr ,l))
(defmacro do-result-form (l)
	  `(cadddr ,l))
(defmacro do-body (l)
	 `(cadr (cdddr ,l)))
(defmacro do-valuep (l)
	 `(caddr (cdddr ,l)))

;;; m-do-assign-1 and m-do-step-1 are the versions of
;;; m-do-assign and m-do-step that are done at initialization
;;; time rather than increment time in the loop. It is so
;;; that (do ((l l (cdr l)))...) can work.

(defun m-do-assign ()
       (mapc #'(lambda (var)
		       (m-assign var (pop *evarg-stack*)))
	     (do-vars (top *pc-stack*)))
       (push (do-test-form (top *pc-stack*))
	     *arg-stack*)
       (push 'm-do-test *pc-stack*)
       (push 'm-eval *pc-stack*))

(defun m-do-assign-1 ()
       (mapc #'(lambda (var)
		       (m-add-env var (pop *evarg-stack*)))
	     (do-vars (top *pc-stack*)))
       (push (do-test-form (top *pc-stack*))
	     *arg-stack*)
       (push 'm-do-test *pc-stack*)
       (push 'm-eval *pc-stack*))

(defun m-do-test ()
       (let ((val (top *arg-stack*)))
	    (cond (val
		   (cond ((do-result-form (top *pc-stack*))
			  (setf (top *arg-stack*)
				(do-result-form (top *pc-stack*)))
			  (setq *valuep* (do-valuep (top *pc-stack*)))
			  (setf (top *pc-stack*) 'm-eval)
				)
			 (t 
			  (setf (top *arg-stack*) ())
			  (pop *pc-stack*))))
		  (t (let ((body 
			    (do-body (top *pc-stack*)))
			   (steppers (do-steppers (top *pc-stack*))))
			  (pop *arg-stack*)
			  (m-do-step steppers)
			  (push 'm-flush-top-arg-stack *pc-stack*)
			  (push 'm-eval *pc-stack*)
			  (setq *valuep* ())
			  (push body *arg-stack*)
			  )))))

(defun m-do-step (l)
       (push 'm-do-assign *pc-stack*)
       (do ((l l (cdr l)))
	   ((null l) t)
	   (push 'm-stash-arg *pc-stack*)
	   (push 'm-eval *pc-stack*)
	   (push (car l) *arg-stack*)))

(defun m-do-step-1 (l)
       (push 'm-do-assign-1 *pc-stack*)
       (do ((l l (cdr l)))
	   ((null l) t)
	   (push 'm-stash-arg *pc-stack*)
	   (push 'm-eval *pc-stack*)
	   (push (car l) *arg-stack*)))
;;; Definitions

(defun m-defun fexpr (args)
 (putprop (car args)
	  `(lambda ,(cadr args)
		   ,(m-prognify (cddr args)))
	  'm-expr) 
 (car args))

(defun m-qdefun fexpr (args)
 (putprop (car args)
	  `(qlambda ,(cadr args) ,(caddr args)
		   ,(m-prognify (cdddr args)))
	  'm-expr) 
 (car args))
;;; Simple Allocation Routines

(defmacro memq-and-remove (x l)
	  `(cond ((eq ,x (car ,l))
		  (setq ,l (cdr ,l))
		  t)
		 (t (do ((l ,l (cdr l))
			 (next (cdr ,l) (cdr next)))
			((null l) ())
			(cond ((eq ,x (car next))
			       (setf (cdr l) (cdr next))
			       (return t)))))))

(defun allocate (n)
 (let ((new (+ *number-of-processes* n)))
      (cond ((< new *max-number-of-processes*)
	     (push *self* *allocate-stack*)
	     (setq *number-of-processes* new)
	     t))))

(defun de-allocate (n)
       (and (memq-and-remove *self* *allocate-stack*)
	    (setq *number-of-processes* (max 0 (- *number-of-processes* n)))))

;;; Simple 1-dimensional array stuff

(defun aref (ar n)
       (arraycall t ar n))

(defun aset (ar n v)
       (store (arraycall t ar n) v))

(defun make-array (n)
       (*array () t n))

(defun ≤ (x y)
       (not (< y x)))

(defun ≥ (x y)
       (not (< x y)))

;;; Useful Macros for the Running System.
(eval-when (compile eval) (setq defmacro-for-compiling t))
(defmacro spawn (form)
	  `(funcall (qlambda t () ,form)))

(defmacro wait (form)
	  `((lambda (x) x) ,form))

(defmacro no-wait (form)
	  `(progn  ,form ()))

(eval-when (compile eval) (setq defmacro-for-compiling ()))
;;; Simple Lock Mechanism

;;; (Create-lock <name>), returns a lock
;;; (Get-lock <lock>), returns a lock
;;; (Release-lock <lock>), returns a lock

(defstruct (lock (conc-name lock-))
	   (owner ())
	   (serial ())
	   (queue (make-queue)))

(defmacro make-lock-request (owner)
	  ``(,,owner . ,(ncons ())))

(defmacro lock-request-owner (request) `(car ,request))

(defmacro lock-request-serial (request) `(cdr ,request))

(defmacro make-lock-wait-info (lock serial) ``(,,lock . ,,serial))

(defmacro lock-wait-info-lock (info) `(car ,info))

(defmacro lock-wait-info-serial (info) `(cdr ,info))

(defun create-lock ()
       (make-lock))

(defun get-lock (lock)
       (cond ((null (lock-owner lock))
	      (setf (lock-owner lock) *self*)
	      (setf (lock-serial lock) (ncons ()))
	      lock)
	     (t (let ((request 
		       (make-lock-request *self*)))
		     (add-queue request
				(lock-queue lock))
		     (setf (job-active *self*) 'wait)
		     (setf (job-waiter *self*) 'm-wait-for-lock)
		     (make-lock-wait-info 
		      lock 
		      (lock-request-serial request))))))

(defun m-wait-for-lock ()
       (let ((top (top *arg-stack*)))
	    (cond ((and (eq (lock-owner (lock-wait-info-lock top)) *self*)
			(eq (lock-serial (lock-wait-info-lock top)) 
			    (lock-wait-info-serial top)))
		   (setf (top *arg-stack*) (lock-wait-info-lock top))
		   t))))

(defun release-lock (lock)
       (let ((request
	      (remove-head-queue (lock-queue lock))))
	    (setf (lock-owner lock) (lock-request-owner request))
	    (setf (lock-serial lock) (lock-request-serial request))
	    lock))

(defun clear-lock (lock)
       (setf (lock-owner lock) ())
       (setf (lock-serial lock) ())
       (setf (lock-queue lock) (make-queue)))

(defun m-if-lockp ()
       (let ((lock (pop *arg-stack*)))
	    (cond ((null (lock-owner lock))
		   (setf (lock-owner lock) *self*)
		   (setf (lock-serial lock) (ncons ()))
		   (let ((form (pop *pc-stack*)))
			(setf (top *pc-stack*) lock)
			(push 'm-release-lock *pc-stack*)
			(push form *arg-stack*)
			(push 'm-eval *pc-stack*)))
		  (t (pop *pc-stack*)
		     (push (pop *pc-stack*) *arg-stack*)
		     (push 'm-eval *pc-stack*)))))

(defun m-release-lock ()
       (release-lock (pop *pc-stack*)))
;;; Startup

(defun make-multi-processor (n)
       (m-init-world)
       (setq *machine*
	     (make-machine number n
			   processors
			   (do ((n n (1- n))
				(pr () (push (make-processor) pr)))
			       ((zerop n) pr)))) 
       t)

(defun eval-forms (&rest forms)
       (m-init-world)
       (setf (machine-list *machine*)
	     (mapcar #'(lambda (x)
			       (make-job
				arg-stack (ncons x)
				job-expression x
				pc-stack `(m-eval m-restore-env ,*environment*)
				job-waiter 'm-null-wait
				job-active 'alive))
		     forms)) 
       t)

(defun eval-form (form)
       (m-init-world)
       (setf (machine-list *machine*)
	     `(,(make-job
		 arg-stack (ncons form)
		 job-expression form
		 pc-stack `(m-eval m-restore-env ,*environment*)
		 job-waiter 'm-null-wait
		 job-active 'alive))) 
       t)

(defun print-jobs ()
       (do ((pr (machine-processors *machine*) (cdr pr))
	    (n 0))
	   ((null pr) 
	    (terpri)
	    (princ "Number of jobs: ")(princ n)(terpri))
	   (let ((first (car (qhead (processor-job-queue (car pr))))))
		(do ((jobs (qhead (processor-job-queue (car pr)))
			   (cdr jobs))
		     (ojobs () (cdr jobs)))
		    ((eq (car ojobs) first)
		     t)
		    (setq n (1+ n))
		    (terpri)
		    (princ (job-expression (car jobs)))
		    (tab)
		    (princ (job-active (car jobs)))
		    (tab)
		    (princ (job-waiter (car jobs)))))))

(defun number-of-jobs ()
       (do ((pr (machine-processors *machine*) (cdr pr))
	    (n 0))
	   ((null pr) 
	    n)
	   (let ((first (car (qhead (processor-job-queue (car pr))))))
		(do ((jobs (qhead (processor-job-queue (car pr)))
			   (cdr jobs))
		     (ojobs () (cdr jobs)))
		    ((eq (car ojobs) first)
		     t)
		    (setq n (1+ n))))))

(defun meval (form)
       (setq *meter* (make-meter))
       (setq *catch-thread* ())
       (setf (meter-processors *meter*) (machine-number *machine*))
       (eval-form `(print (setq *val* ,form)))
       (run *machine*)
       (report))

(defun toplevel ()
       (princ "=> ")
       (do ((x (read)(read)))
	   (())
	   (cond ((not (atom x))
		  (cond ((memq (car x) 
			       '(defmacro defun m-defun m-qdefun fasload))
			 (print (eval x)))
			((eq (car x) 'setq)
			 (do ((l (cdr x) (cddr l)))
			     ((null l) *val*)
			     (let ((*silence* t))
				    (meval (cadr l)))
           		     (set (car l) *val*)))
			(t 
			 (meval x)))) 
		 (t (meval x)))
	   (terpri)
	   (princ "=> ")
	   ))

(defun startup (n &optional (m (* 2 n)))
       (make-multi-processor n)
       (setq *number-of-processes* 0)
       (setq *max-number-of-processes* m)
       (terpri) (princ "Multi-processing Lisp with ")
       (princ n) (princ " processors.")
       (terpri)
       (toplevel))